home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / psgml / psgml-info.el.z / psgml-info.el
Encoding:
Text File  |  1998-05-21  |  11.9 KB  |  414 lines
  1. ;;;; psgml-info.el
  2. ;;; Last edited: Wed Mar 20 21:24:16 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
  3. ;;; $Id: psgml-info.el,v 2.4 1996/03/31 21:31:38 lenst Exp $
  4.  
  5. ;; Copyright (C) 1994, 1995 Lennart Staflin
  6.  
  7. ;; Author: Lennart Staflin <lenst@lysator.liu.se>
  8.  
  9. ;; This program is free software; you can redistribute it and/or
  10. ;; modify it under the terms of the GNU General Public License
  11. ;; as published by the Free Software Foundation; either version 2
  12. ;; of the License, or (at your option) any later version.
  13. ;; 
  14. ;; This program is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18. ;; 
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with this program; if not, write to the Free Software
  21. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23.  
  24. ;;;; Commentary:
  25.  
  26. ;; This file is an addon to the PSGML package.  
  27.  
  28. ;; This file contains some commands to print out information about the
  29. ;; current DTD.
  30.  
  31. ;; sgml-list-elements
  32. ;;    Will list all elements and the attributes declared for the element.
  33.  
  34. ;; sgml-list-attributes
  35. ;;    Will list all attributes declared and the elements that use them.
  36.  
  37. ;; sgml-list-terminals
  38. ;;    Will list all elements that can contain data.
  39.  
  40. ;; sgml-list-occur-in-elements
  41. ;;    Will list all element types and where it can occur.
  42.  
  43. ;; sgml-list-content-elements
  44. ;;    Will list all element types and the element types that can occur
  45. ;;    in its content.
  46.  
  47. ;;;; Code:
  48.  
  49. (require 'psgml)
  50. (require 'psgml-parse)
  51.  
  52. (defconst sgml-attr-col 18)
  53.  
  54.  
  55. ;;;; Utility functions
  56.  
  57. (defsubst sgml-add-to-table (row-index elem table)
  58.   (let ((p (assoc row-index table)))
  59.     (cond ((null p)
  60.        (cons (list row-index elem) table))
  61.       (t
  62.        (nconc p (list elem))
  63.        table))))
  64.  
  65. (defsubst sgml-add-last-unique (x l)
  66.   (unless (memq x l)
  67.     (nconc l (list x))))
  68.  
  69. (defun sgml-map-element-types (func)
  70.   (sgml-need-dtd)
  71.   (sgml-map-eltypes func
  72.             (sgml-pstate-dtd sgml-buffer-parse-state)
  73.             t))
  74.  
  75. (defun sgml-eltype-refrenced-elements (eltype)
  76.   "List of element types referenced in the model of ELTYPE."
  77.   ;; Now with cache. Uses appdata prop re-cache.
  78.   (or
  79.    (sgml-eltype-appdata eltype 're-cache)
  80.    (let* ((res                ; result list (eltypes)
  81.        nil)
  82.       (states            ; list of states
  83.        (list (sgml-eltype-model eltype)))
  84.       (agenda            ; point into states
  85.        states))
  86.      (cond
  87.       ((not (sgml-model-group-p (car states)))
  88.        nil)
  89.       (t
  90.        (while agenda
  91.      (cond
  92.       ((sgml-normal-state-p (car agenda))
  93.        (loop for m in (append (sgml-state-opts (car agenda))
  94.                   (sgml-state-reqs (car agenda)))
  95.          do
  96.          (pushnew (sgml-move-token m) res)
  97.          (sgml-add-last-unique (sgml-move-dest m) states)))
  98.        
  99.       (t                ; &-node
  100.        (sgml-add-last-unique (sgml-and-node-next (car agenda)) states)
  101.        (loop for dfa in (sgml-and-node-dfas (car agenda)) do
  102.          (sgml-add-last-unique dfa states))))
  103.      (setq agenda (cdr agenda)))
  104.        (setq res (sort (set-difference
  105.             (union res (sgml-eltype-includes eltype))
  106.             (sgml-eltype-excludes eltype))
  107.                (function string-lessp)))
  108.        (setf (sgml-eltype-appdata eltype 're-cache) res)
  109.        res)))))
  110.  
  111.  
  112. ;;;; List elements
  113.  
  114. (defun sgml-list-elements ()
  115.   "List the elements and their attributes in the current DTD."
  116.   (interactive)
  117.   (message "Creating table...")
  118.   (sgml-display-table
  119.    (sgml-map-element-types
  120.     (function
  121.      (lambda (eltype)
  122.        (cons (sgml-eltype-name eltype)
  123.          (mapcar (function sgml-attdecl-name)
  124.              (sgml-eltype-attlist eltype))))))
  125.    "Elements" "Element" "Attribute"))
  126.  
  127.  
  128. ;;;; List attributes
  129.  
  130. (defun sgml-list-attributes ()
  131.   "List the attributes and in which elements they occur."
  132.   (interactive)
  133.   (let ((attributes nil))
  134.     (message "Creating table...")
  135.     (sgml-map-element-types
  136.      (function
  137.       (lambda (eltype)
  138.     (loop for a in (sgml-eltype-attlist eltype) do
  139.           (setq attributes
  140.             (sgml-add-to-table (sgml-attdecl-name a)
  141.                        (sgml-eltype-name eltype)
  142.                        attributes))))))
  143.     (sgml-display-table attributes
  144.             "Attributes" "Attribute" "Element")))
  145.  
  146.  
  147.  
  148.  
  149. ;;;; List terminals
  150.  
  151. (defun sgml-list-terminals ()
  152.   "List the elements that can have data in their content."
  153.   (interactive)
  154.   (message "Creating table...")
  155.   (let ((data-models (list sgml-cdata sgml-rcdata sgml-any)))
  156.     (sgml-display-table
  157.      (delq nil
  158.        (sgml-map-element-types
  159.         (function
  160.          (lambda (eltype)
  161.            (if (or (sgml-eltype-mixed eltype)
  162.                (memq (sgml-eltype-model eltype) data-models))
  163.            (list (sgml-eltype-name eltype)
  164.              (symbol-name
  165.               (if (sgml-model-group-p (sgml-eltype-model eltype))
  166.                   'mixed
  167.                 (sgml-eltype-model eltype)))))))))
  168.      "Terminals" "Element" "Content")))
  169.  
  170.  
  171. ;;;; Element cross reference list
  172.  
  173. (defun sgml-list-content-elements ()
  174.   "List all element types and the element types that can occur in its content."
  175.   (interactive)
  176.   (message "Creating table...")
  177.   (sgml-display-table
  178.    (sgml-map-element-types
  179.     (function
  180.      (lambda (eltype)
  181.        (cons (sgml-eltype-name eltype)
  182.          (mapcar (function sgml-eltype-name)
  183.              (sgml-eltype-refrenced-elements eltype))))))
  184.    "Elements refrenced by elements"
  185.    "Element" "Content"))
  186.  
  187. (defun sgml-list-occur-in-elements ()
  188.   "List all element types and where it can occur."
  189.   (interactive)
  190.   (message "Creating table...")
  191.   (let ((cross nil))
  192.     (sgml-map-element-types
  193.      (function
  194.       (lambda (eltype)
  195.     (loop for ref in (sgml-eltype-refrenced-elements eltype)
  196.           do (setq cross (sgml-add-to-table ref
  197.                         (sgml-eltype-name eltype)
  198.                         cross))))))
  199.     (sgml-display-table
  200.      cross
  201.      "Cross referenced element types" "Element" "Can occur in")))
  202.  
  203.  
  204. ;;;; Display table
  205.  
  206. (defun sgml-display-table (table title col-title1 col-title2
  207.                  &optional width nosort)
  208.   (or width
  209.       (setq width sgml-attr-col))
  210.   (let ((buf (get-buffer-create (format "*%s*" title))))
  211.     (message "Preparing display...")
  212.     (set-buffer buf)
  213.     (erase-buffer)
  214.     (insert col-title1)
  215.     (indent-to width)
  216.     (insert col-title2 "\n")
  217.     (insert-char ?= (length col-title1))
  218.     (indent-to width)
  219.     (insert-char ?= (length col-title2))
  220.     (insert "\n")
  221.     (unless nosort
  222.       (setq table (sort table (function (lambda (a b)
  223.                       (string< (car a) (car b)))))))
  224.     (loop for e in table do
  225.       (insert (format "%s" (car e)))
  226.       (loop for name in (if nosort
  227.                 (cdr e)
  228.                   (sort (cdr e) (function string-lessp)))
  229.         do
  230.         (when (> (+ (length name) (current-column))
  231.              fill-column)
  232.           (insert "\n"))
  233.         (when (< (current-column) sgml-attr-col)
  234.           (indent-to width))
  235.         (insert  name " "))
  236.       (insert "\n"))
  237.     (goto-char (point-min))
  238.     (display-buffer buf)
  239.     (message nil)))
  240.  
  241.  
  242. ;;;; Describe entity
  243.  
  244. (defun sgml-describe-entity (name)
  245.   "Describe the properties of an entity as declared in the current DTD."
  246.   (interactive
  247.    (let (default input)
  248.      (sgml-need-dtd)
  249.      (save-excursion
  250.        (sgml-with-parser-syntax
  251.     (unless (sgml-parse-delim "ERO")
  252.       (skip-chars-backward "^&\"'= \t\n"))
  253.     (setq default (or (sgml-parse-name t) ""))))
  254.      (setq input (completing-read
  255.           (format "Entity name (%s): " default)
  256.           (sgml-entity-completion-table
  257.            (sgml-dtd-entities
  258.             (sgml-pstate-dtd sgml-buffer-parse-state)))))
  259.      (list
  260.       (if (equal "" input) default input))))
  261.   
  262.   (with-output-to-temp-buffer "*Help*"
  263.     (let ((entity (sgml-lookup-entity name
  264.                       (sgml-dtd-entities
  265.                        (sgml-pstate-dtd
  266.                     sgml-buffer-parse-state)))))
  267.       (or entity (error "Undefined entity"))
  268.       (princ (format "Entity %s is %s\n"
  269.              name
  270.              (cond ((null entity)
  271.                 "undefined")
  272.                (t
  273.                 (format "a %s entity"
  274.                     (sgml-entity-type entity))))))
  275.       (when entity
  276.     (let ((text (sgml-entity-text entity)))
  277.       (cond ((stringp text)
  278.          (princ "Defined to be:\n")
  279.          (princ text))
  280.         (t
  281.          (princ "With external identifier ")
  282.          (princ (if (car text) "PUBLIC" "SYSTEM")) 
  283.          (when (car text)
  284.            (princ (format " '%s'" (car text))))
  285.          (when (cdr text)
  286.            (princ (format " '%s'" (cdr text)))))))))))
  287.  
  288.  
  289.  
  290. ;;;; Describe element type
  291.  
  292. (defun sgml-describe-element-type (et-name)
  293.   "Describe the properties of an element type as declared in the current DTD."
  294.   (interactive
  295.    (let (default input)
  296.      (sgml-need-dtd)
  297.      (save-excursion
  298.        (sgml-with-parser-syntax
  299.     (unless (sgml-parse-delim "STAGO")
  300.       (skip-syntax-backward "w_"))
  301.     (setq default (sgml-parse-name))
  302.     (unless (and default
  303.              (sgml-eltype-defined (sgml-lookup-eltype default)))
  304.       (setq default nil))))
  305.      (setq input (sgml-read-element-type (if default
  306.                          (format "Element type (%s): "
  307.                              default)
  308.                        "Element type: ")
  309.                      sgml-dtd-info
  310.                      default))
  311.  
  312.      (list
  313.       (sgml-eltype-name input))))
  314.  
  315.   (sgml-need-dtd)
  316.   (let ((et (sgml-lookup-eltype et-name)))
  317.     (with-output-to-temp-buffer "*Help*"
  318.       (princ (format "ELEMENT: %s\n\n" (sgml-eltype-name et)))
  319.       (princ (format " Start-tag is %s.\n End-tag is %s.\n"
  320.              (if (sgml-eltype-stag-optional et)
  321.              "optional" "required")
  322.              (if (sgml-eltype-etag-optional et)
  323.              "optional" "required")))
  324.       (princ "\nATTRIBUTES:\n")
  325.       (loop for attdecl in (sgml-eltype-attlist et) do
  326.         (let ((name (sgml-attdecl-name attdecl))
  327.           (dval (sgml-attdecl-declared-value attdecl))
  328.           (defl (sgml-attdecl-default-value attdecl)))
  329.           (when (listp dval)
  330.         (setq dval (concat (if (eq (first dval)
  331.                        'notation)
  332.                        "#NOTATION (" "(")
  333.                    (mapconcat (function identity)
  334.                           (second dval)
  335.                           "|")
  336.                    ")")))
  337.           (cond ((sgml-default-value-type-p 'fixed defl)
  338.              (setq defl (format "#FIXED '%s'"
  339.                     (sgml-default-value-attval defl))))
  340.             ((symbolp defl)
  341.              (setq defl (upcase (format "#%s" defl))))
  342.             (t
  343.              (setq defl (format "'%s'"
  344.                     (sgml-default-value-attval defl)))))
  345.           (princ (format " %-9s %-30s %s\n" name dval defl))))
  346.       ;; ----
  347.       (let ((s (sgml-eltype-shortmap et)))
  348.     (when s
  349.       (princ (format "\nUSEMAP: %s\n" s))))
  350.       ;; ----
  351.       (princ "\nOCCURS IN:\n\n")
  352.       (let ((occurs-in ()))
  353.     (sgml-map-eltypes
  354.      (function (lambda (cand)
  355.              (when (memq et (sgml-eltype-refrenced-elements cand))
  356.                (push cand occurs-in))))
  357.      (sgml-pstate-dtd sgml-buffer-parse-state))
  358.  
  359.     (loop with col = 0
  360.           for occur-et in (sort occurs-in (function string-lessp))
  361.           for name = (sgml-eltype-name occur-et)
  362.           do
  363.           (when (and (> col 0) (> (+ col (length name) 1) fill-column))
  364.         (princ "\n")
  365.         (setq col 0))
  366.           (princ " ") (princ name)
  367.           (incf col (length name))
  368.           (incf col 1))))))
  369.  
  370.  
  371. ;;;; Print general info about the DTD.
  372.  
  373. (defun sgml-general-dtd-info ()
  374.   "Display information about the current DTD."
  375.   (interactive)
  376.   (sgml-need-dtd)
  377.   (let ((elements 0)
  378.     (entities 0)
  379.     (parameters 0)
  380.     (fmt "%20s %s\n")
  381.     (hdr "")
  382.     )
  383.     (sgml-map-eltypes (function (lambda (e) (incf elements)))
  384.               sgml-dtd-info)
  385.     (sgml-map-entities (function (lambda (e) (incf entities)))
  386.                (sgml-dtd-entities sgml-dtd-info))
  387.     (sgml-map-entities (function (lambda (e) (incf parameters)))
  388.                (sgml-dtd-parameters sgml-dtd-info))
  389.  
  390.     (with-output-to-temp-buffer "*Help*"
  391.       (princ (format fmt "Doctype:" (sgml-dtd-doctype sgml-dtd-info)))
  392.       (when (sgml-dtd-merged sgml-dtd-info)
  393.     (princ (format fmt "Compiled DTD:"
  394.                (car (sgml-dtd-merged sgml-dtd-info)))))
  395.       (princ (format fmt "Element types:" (format "%d" elements)))
  396.       (princ (format fmt "Entities:" (format "%d" entities)))
  397.       (princ (format fmt "Parameter entities:" (format "%d" parameters)))
  398.  
  399.       (setq hdr "Files used:")
  400.       (loop for x in (sgml-dtd-dependencies sgml-dtd-info)
  401.         if (stringp x)
  402.         do (princ (format fmt hdr x))
  403.         (setq hdr ""))
  404.  
  405.       (setq hdr "Undef parameters:")
  406.       (sgml-map-entities
  407.        (function (lambda (entity)
  408.            (when (sgml-entity-marked-undefined-p entity)
  409.              (princ (format fmt hdr (sgml-entity-name entity)))
  410.              (setq hdr ""))))
  411.        (sgml-dtd-parameters sgml-dtd-info)))))
  412.  
  413. ;;; psgml-info.el ends here
  414.